home *** CD-ROM | disk | FTP | other *** search
/ Revista CD Expert 8 / Revista CD Expert nº 08 CD1.iso / Utilitarios / Programacao / MS-DOS Interrupt List / inter60f / INT2RTF.ZIP / RTF.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1996-10-09  |  14.8 KB  |  576 lines
  1. { RTF unit for the Interrupt List -> .RTF compiler.            }
  2. { The software included, data formats and basic algorithms are }
  3. { copyright (C) 1996 by Slava Gostrenko. All rights reserved.  }
  4.  
  5. {$X+}
  6. unit
  7.   RTF;
  8.  
  9. interface
  10.  
  11. uses
  12.   Objects;
  13.  
  14. const
  15.   HexChars = ['0'..'9', 'A'..'F', 'a'..'f'];
  16.  
  17.   TPFileStamp = '{\rtf1\pc \deff1{\fonttbl{\f0\froman Times New Roman;}'#$D#$A
  18.               + '{\f1\fmodern Courier New;}}'#$D#$A
  19.               + '{\colortbl \red255\green0\blue0;\red0\green0\blue0;'#$D#$A
  20.               + '\red0\green0\blue255;\red255\green255\blue255;}'#$D#$A
  21.               + '\plain\fs18\pard\keep'#$D#$A;
  22.  
  23.   FileStamp : array [0 .. Length (TPFileStamp) - 1] of Char = TPFileStamp;
  24.  
  25. type
  26.   PIdxTbl = ^TIdxTbl;
  27.   TIdxTbl = object (TSortedCollection)
  28.     function  KeyOf (Item: Pointer): Pointer; virtual;
  29.     function  Compare (Key1, Key2: Pointer): Integer; virtual;
  30.     procedure SetCtxs;
  31.   end;
  32.  
  33.   PTopic = ^TTopic;
  34.   TTopic = object (TStringCollection)
  35.     Header,
  36.     SubHeader: PString;
  37.  
  38.     Keywords: TStringCollection;
  39.     InSwap: Boolean;
  40.     SwapPos: Longint;
  41.  
  42.     constructor Init(ALimit, ADelta: Integer);
  43.     destructor  Done; virtual;
  44.  
  45.     procedure   SetHeader (const S: string);
  46.     procedure   SetSubHeader (const S: string);
  47.  
  48.     procedure   Store2Swap (var S: TStream);
  49.     procedure   RestoreFromSwap (var S: TStream);
  50.  
  51.     procedure   AddString (S: string);
  52.     procedure   Write (var S: TStream; var IdxTbl: TIdxTbl;
  53.                        Ctx: Word; const Title: string);
  54.  
  55.     procedure   AddKeyword (S: string; StepBack: Integer);
  56.     procedure   AddKeywordAtStart (S: string);
  57.     function    ResolveKeyword (const I: Integer; var IdxTbl: TIdxTbl): Word;
  58.   end;
  59.  
  60.   PIndexEntry = ^TIndexEntry;
  61.   TIndexEntry = object (TObject)
  62.     PS: PString;
  63.     Ctx: Word;
  64.     Topic: PTopic;
  65.  
  66.     constructor Init (const S: string; ACtx: Word; var ATopic: PTopic);
  67.     destructor  Done; virtual;
  68.   end;
  69.  
  70.   PHelpFile = ^THelpFile;
  71.   THelpFile = object (TBufStream)
  72.     IdxTbl: TIdxTbl;
  73.  
  74.     constructor Init(FileName: FNameStr; Mode, Size: Word);
  75.     destructor  Done; virtual;
  76.   end;
  77.  
  78. var
  79.   SwapFile: PBufStream;
  80.  
  81.   BoldNames: TStringCollection;
  82.  
  83. implementation
  84.  
  85. uses
  86.   Upcaser;
  87.  
  88. const EmptyString : string[1] = '';
  89.  
  90. function  PStr(P: PString): PString; {returns pointer to empty string if p = nil}
  91. inline (
  92.   $58/                {Pop    AX}
  93.   $5A/                {Pop    DX}
  94.   $0B/ $D2/           {Or     DX, DX}
  95.   $75/ $05/           {JNE    Exit}
  96.   $8C/ $DA/           {MOV    DX, DS}
  97.   $B8/ >EmptyString   {MOV    AX, offset EmptyString}
  98. );
  99.  
  100. { TTopic = object (TStringCollection) }
  101.  
  102. constructor TTopic. Init(ALimit, ADelta: Integer);
  103. begin
  104.   inherited Init (ALimit, ADelta);
  105.   Keywords. Init (ALimit, ADelta);
  106.  
  107.   InSwap := False;
  108.   SwapPos := -1;
  109.  
  110.   Header := nil;
  111.   SubHeader := nil;
  112. end;
  113.  
  114. destructor  TTopic. Done;
  115. begin
  116.   DisposeStr (Header);
  117.   DisposeStr (SubHeader);
  118.  
  119.   inherited Done;
  120. end;
  121.  
  122. procedure   TTopic. SetHeader (const S: string);
  123. begin
  124.   Header := NewStr (S);
  125. end;
  126.  
  127. procedure   TTopic. SetSubHeader (const S: string);
  128. begin
  129.   SubHeader := NewStr (S);
  130. end;
  131.  
  132. procedure   TTopic. Store2Swap (var S: TStream);
  133. var I: Integer;
  134. begin
  135.   if not InSwap then begin
  136.     if SwapPos = -1 then begin
  137.       SwapPos := S. GetSize;
  138.       S. Seek (SwapPos);
  139.       S. Write (Count, 2);
  140.  
  141.       if Count > 0 then
  142.         for I := 0 to Count - 1 do begin
  143.           S. WriteStr (Items^[I]);
  144.           DisposeStr (Items^[I]);
  145.           Items^[I] := nil;
  146.         end;
  147.  
  148.       S. WriteStr (SubHeader);
  149.       DisposeStr (SubHeader);
  150.       SubHeader := nil;
  151.     end else begin
  152.       if Count > 0 then
  153.         for I := 0 to Count - 1 do begin
  154.           DisposeStr (Items^[I]);
  155.           Items^[I] := nil;
  156.         end;
  157.  
  158.       DisposeStr (SubHeader);
  159.       SubHeader := nil;
  160.     end;
  161.  
  162.     InSwap := True;
  163.   end;
  164. end;
  165.  
  166. procedure   TTopic. RestoreFromSwap (var S: TStream);
  167. var I, C: Integer;
  168. begin
  169.   if InSwap then
  170.     if SwapPos = -1 then begin
  171.       WriteLn ('Swapping error 2');
  172.       Halt (1);
  173.     end else begin
  174.       S. Seek (SwapPos);
  175.       S. Read (C, 2);
  176.  
  177.       if C > 0 then
  178.         for I := 0 to C - 1 do
  179.           Items^[I] := S. ReadStr;
  180.  
  181.       SubHeader := S. ReadStr;
  182.  
  183.       InSwap := False;
  184.     end;
  185. end;
  186.  
  187. procedure   TTopic. AddString (S: string);
  188. begin
  189.   AtInsert (Count, NewStr (S));
  190. end;
  191.  
  192. procedure TTopic. Write (var S: TStream; var IdxTbl: TIdxTbl;
  193.                          Ctx: Word; const Title: string);
  194.  
  195.   const StartTopic = '\pard\keepn\li1060\fi-1060'#$D#$A;
  196.         StartTopicStr: string [Length (StartTopic)] = StartTopic;
  197.  
  198.   var   KeywordN: Integer;
  199.         DropOnePar: Boolean;
  200.  
  201.   procedure DoWrite (Str: string; NoPar: Boolean);
  202.  
  203.     procedure MakeBold (var S: string); far;
  204.     var OldI, I: Integer;
  205.     begin
  206.       OldI := 0;
  207.       I := Pos (S, Str);
  208.  
  209.       while I > 0 do begin
  210.         Inc (I, OldI);
  211.  
  212.         System. Insert (#4, Str, I + Length (S));
  213.         System. Insert (#3, Str, I);
  214.  
  215.         OldI := I + Length (S) + 1;
  216.         I := Pos (S, Copy (Str, I + Length (S) + 2, Length (Str)));
  217.       end;
  218.     end;
  219.  
  220.   const EOL: string [2] = #$D#$A;
  221.         Par: string [4] = '\par';
  222.         StartKey: string [7] = '{\uldb ';
  223.         EndKey:   string [5] = '}{\v ';
  224.         StartBold: string [4] = '{\b ';
  225.  
  226.   var I: Integer;
  227.       C: Char;
  228.       LinkStr: string;
  229.       StartFrom: Integer;
  230.   begin
  231.     BoldNames. ForEach (@MakeBold);
  232.  
  233.     StartFrom := 1;
  234.  
  235.     if NoPar then begin
  236.       if (Length (Str) > 0) and (Str [1] = ' ') then
  237.         StartFrom := 2;
  238.     end else begin
  239.       S. Write (Par [1], Length (Par));
  240.  
  241.       if (Length (Str) > 0) and (Str [1] <> ' ') then begin
  242.         C := ' '; S. Write (C, 1);
  243.       end;
  244.     end;
  245.  
  246.     for I := StartFrom to Length (Str) do
  247.       case Str [I] of
  248.       #2: begin
  249.             if Odd (KeywordN) then begin
  250.               S. Write (EndKey [1], Length (EndKey));
  251.               System. Str (ResolveKeyword (KeywordN div 2, IdxTbl), LinkStr);
  252.               S. Write (LinkStr [1], Length (LinkStr));
  253.               C := '}'; S. Write (C, 1);
  254.             end else
  255.               S. Write (StartKey [1], Length (StartKey));
  256.  
  257.             Inc (KeywordN);
  258.           end;
  259.       #3: S. Write (StartBold [1], Length (StartBold));
  260.       #4: begin C := '}'; S. Write (C, 1); end;
  261.  
  262.       'ü': begin C := 'u'; S. Write (C, 1); end;
  263.       'µ': begin C := 'u'; S. Write (C, 1); end;
  264.       '²': begin C := '2'; S. Write (C, 1); end;
  265.       'á': begin C := 'a'; S. Write (C, 1); end;
  266.       '─': begin C := '-'; S. Write (C, 1); end;
  267.       '│': begin C := '|'; S. Write (C, 1); end;
  268.       '┬': begin C := '+'; S. Write (C, 1); end;
  269.  
  270.       '┴': begin C := '+'; S. Write (C, 1); end;
  271.       '├': begin C := '+'; S. Write (C, 1); end;
  272.  
  273.       '┤': begin C := '+'; S. Write (C, 1); end;
  274.  
  275.       '┼': begin C := '+'; S. Write (C, 1); end;
  276.       '┌': begin C := '+'; S. Write (C, 1); end;
  277.       '┐': begin C := '+'; S. Write (C, 1); end;
  278.  
  279.       '└': begin C := '+'; S. Write (C, 1); end;
  280.       '┘': begin C := '+'; S. Write (C, 1); end;
  281.       '╒': begin C := '+'; S. Write (C, 1); end;
  282.       '╤': begin C := '+'; S. Write (C, 1); end;
  283.       '╕': begin C := '+'; S. Write (C, 1); end;
  284.  
  285.       '╞': begin C := '+'; S. Write (C, 1); end;
  286.  
  287.       '╪': begin C := '+'; S. Write (C, 1); end;
  288.  
  289.       '╡': begin C := '+'; S. Write (C, 1); end;
  290.  
  291.       '╘': begin C := '+'; S. Write (C, 1); end;
  292.       '╧': begin C := '+'; S. Write (C, 1); end;
  293.       '╛': begin C := '+'; S. Write (C, 1); end;
  294.       '═': begin C := '='; S. Write (C, 1); end;
  295.  
  296.       'Σ': begin C := 'E'; S. Write (C, 1); end;
  297.       'é': begin C := 'e'; S. Write (C, 1); end;
  298.       'ä': begin C := 'a'; S. Write (C, 1); end;
  299.       'ó': begin C := 'o'; S. Write (C, 1); end;
  300.       'ö': begin C := 'o'; S. Write (C, 1); end;
  301.       '\', '{', '}':
  302.            begin
  303.              C := '\'; S. Write (C, 1);
  304.              S. Write ((@(Str [I]))^, 1);
  305.            end;
  306.       else
  307.         S. Write ((@(Str [I]))^, 1);
  308.       end;
  309.     S. Write (EOL [1], 2);
  310.   end;
  311.  
  312.   procedure WriteOneString (PS: PString); far;
  313.   begin
  314.     if PS <> nil then
  315.       DoWrite (PS^, DropOnePar)
  316.     else
  317.       DoWrite ('', DropOnePar);
  318.  
  319.     DropOnePar := False;
  320.   end;
  321.  
  322. var CtxStr, Str: string;
  323.  
  324. begin
  325.   RestoreFromSwap (SwapFile^);
  326.  
  327.   S. Write (StartTopicStr [1], Length (StartTopicStr));
  328.  
  329.   System. Str (Ctx, CtxStr);
  330.   Str := '#{\footnote{#} ' + CtxStr + '}'#$D#$A;
  331.   S. Write (Str [1], Length (Str));
  332.   Str := '${\footnote{$} ' + Title + '}'#$D#$A;
  333.   S. Write (Str [1], Length (Str));
  334.   Str := '+{\footnote{+} l:0}'#$D#$A;
  335.   S. Write (Str [1], Length (Str));
  336.   Str := 'K{\footnote{K} ' + Title + '}'#$D#$A;
  337.   S. Write (Str [1], Length (Str));
  338.  
  339.   KeywordN := 0;
  340.  
  341.   Str := '{\f0\fs28\keep ';
  342.   S. Write (Str [1], Length (Str));
  343.  
  344.   if Header <> nil then
  345.     DoWrite (Header^, True)
  346.   else
  347.     DoWrite (Title, True);
  348.  
  349.   if SubHeader <> nil then begin
  350.     Str := '{\fs24 ';
  351.     S. Write (Str [1], Length (Str));
  352.     DoWrite (SubHeader^, False);
  353.     Str := '}';
  354.     S. Write (Str [1], Length (Str));
  355.   end;
  356.  
  357.   Str := '}\par\pard\keep'#$D#$A;
  358.   S. Write (Str [1], Length (Str));
  359.  
  360.   DropOnePar := True;
  361.   ForEach (@WriteOneString);
  362.  
  363.   Store2Swap (SwapFile^);
  364. end;
  365.  
  366. procedure   TTopic. AddKeyword (S: string; StepBack: Integer);
  367. begin
  368.   Keywords. AtInsert (Keywords. Count - StepBack, NewStr (S));
  369. end;
  370.  
  371. procedure   TTopic. AddKeywordAtStart (S: string);
  372. begin
  373.   Keywords. AtInsert (0, NewStr (S));
  374. end;
  375.  
  376. function    TTopic. ResolveKeyword (const I: Integer; var IdxTbl: TIdxTbl): Word;
  377. var
  378.   TmpW: Word;
  379.   J, K, MinL, SaveMinLIdx, MatchLen, DecCnt: Integer;
  380.   TmpS, MatchS, Helper: string;
  381.   MatchFound: Boolean;
  382. begin
  383.   if (Keywords. Count > I) and (I >= 0) then begin
  384.     TmpS := StUpcase2 (PString (Keywords. At (I))^);
  385.  
  386.     J := Pos ('"', TmpS);
  387.     if J > 0 then begin
  388.       if TmpS [Length (TmpS)] <> '"' then begin
  389.         Helper := '';
  390.         WriteLn ('error in keyword format - ', TmpS)
  391.       end else begin
  392.         Helper := Copy (TmpS, J + 1, Length (TmpS) - J - 1);
  393.         TmpS [0] := Chr (J - 1);
  394.       end;
  395.     end else
  396.       Helper := '';
  397.  
  398.     DecCnt := 0;
  399.  
  400.     MatchFound := False;
  401.     MinL := High (MinL);
  402.  
  403.     repeat
  404.       IdxTbl. Search (@TmpS, J);
  405.       for K := J to IdxTbl. Count - 1 do begin
  406.         MatchS := StUpcase2 (PIndexEntry (IdxTbl. At (K))^.PS^);
  407.         if Copy (MatchS, 1, Length (TmpS))
  408.         <> TmpS then
  409.           Break
  410.         else begin
  411.           if  ((Helper = '')
  412.             or (Pos (Helper, StUpcase2 (PIndexEntry (
  413.                      IdxTbl. At (K))^. Topic^. Header^)) > 0))
  414.           and (Length (MatchS) - Length (TmpS) < MinL)
  415.           then begin
  416.             MinL := Length (MatchS) - Length (TmpS);
  417.             MatchLen := Length (TmpS);
  418.             SaveMinLIdx := K;
  419.           end;
  420.         end;
  421.       end;
  422.  
  423.       if (DecCnt < 2) and (MinL < High (MinL)) then begin
  424.         MatchFound := True;
  425.         J := SaveMinLIdx;
  426.       end;
  427.  
  428.       Dec (TmpS [0]);
  429.       Inc (DecCnt);
  430.     until MatchFound or (Length (TmpS) < 2);
  431.  
  432.     if (Helper <> '') and (MinL < High (MinL)) then
  433.       MinL := 0;
  434.  
  435.     if not MatchFound then begin
  436.       MatchFound := MinL < High (MinL);
  437.       J := SaveMinLIdx;
  438.     end;
  439.  
  440.     if  ( ((Helper = '') or (MinL = High (MinL)))
  441.       and (((MatchLen < 4) and (MinL > 0)) or (MinL > 1))
  442.         )
  443.     and (TmpS [1] in HexChars) and (TmpS [2] in HexChars) then begin
  444.       TmpS := 'INT ' + TmpS [1] + TmpS [2];
  445.       if not IdxTbl. Search (@TmpS, J) then begin
  446.         WriteLn ('error searching for - ', TmpS);
  447.       end else begin
  448.         MinL := 0;
  449.         MatchFound := True;
  450.       end;
  451.     end;
  452.  
  453.     if  ( ((Helper = '') or (MinL = High (MinL)))
  454.       and (((MatchLen < 5) and (MinL > 0)) or (MinL > 1))
  455.         )
  456.     and (TmpS [1] = 'P')
  457.     and (TmpS [2] in HexChars + ['x', 'X']) and (TmpS [3] in HexChars + ['x', 'X'])
  458.     and (TmpS [4] in HexChars + ['x', 'X']) and (TmpS [5] in HexChars + ['x', 'X']) then begin
  459.       TmpS := 'PORTS';
  460.       if not IdxTbl. Search (@TmpS, J) then begin
  461.         WriteLn ('error searching for - ', TmpS);
  462.       end else begin
  463.         MinL := 0;
  464.         MatchFound := True;
  465.       end;
  466.     end;
  467.  
  468.     TmpW := PIndexEntry (IdxTbl. At (J))^.Ctx;
  469.  
  470.     if not MatchFound then begin
  471.       WriteLn (Header^);
  472.       WriteLn ('error searching for - ', PString (Keywords. At (I))^);
  473.       WriteLn ('found match         - ', PIndexEntry (IdxTbl. At (J))^.PS^);
  474.       TmpW := 1;
  475.     end else
  476.       if MinL > 1 then begin
  477.         WriteLn (Header^);
  478.         WriteLn ('approximate match to - ', PString (Keywords. At (I))^);
  479.         WriteLn ('is                   - ', PIndexEntry (IdxTbl. At (J))^.PS^);
  480.         TmpW := 1;
  481.       end;
  482.  
  483.     ResolveKeyword := TmpW;
  484.   end else begin
  485.     WriteLn ('Internal error - invalid keyword number');
  486.     Halt (1);
  487.   end;
  488. end;
  489.  
  490. { TIndexEntry = object (TObject) }
  491.  
  492. constructor TIndexEntry. Init (const S: string; ACtx: Word; var ATopic: PTopic);
  493. begin
  494.   inherited Init;
  495.   PS := NewStr (S);
  496.   Ctx := ACtx;
  497.  
  498.   Topic := ATopic;
  499.   ATopic := nil;
  500.   Topic^.Store2Swap (SwapFile^);
  501.  
  502.   if Topic^.Header = nil then
  503.     Topic^.SetHeader (S);
  504. end;
  505.  
  506. destructor  TIndexEntry. Done;
  507. begin
  508.   DisposeStr (PS);
  509.   inherited Done;
  510. end;
  511.  
  512. { TIdxTbl = object (TSortedCollection) }
  513.  
  514. function  TIdxTbl. KeyOf (Item: Pointer): Pointer;
  515. begin
  516.   KeyOf := PIndexEntry (Item)^. PS;
  517. end;
  518.  
  519. function  TIdxTbl. Compare (Key1, Key2: Pointer): Integer;
  520. begin
  521.   if (Key1 = nil) or (StUpcase2 (PString (Key1)^) < StUpcase2 (PString (Key2)^)) then
  522.     Compare := -1
  523.   else
  524.     if (Key2 <> nil) and (StUpcase2 (PString (Key1)^) = StUpcase2 (PString (Key2)^)) then
  525.       Compare := 0
  526.     else
  527.       Compare := 1;
  528. end;
  529.  
  530. procedure TIdxTbl. SetCtxs;
  531. var I: Integer;
  532. begin
  533.   for I := 0 to Count - 1 do
  534.     PIndexEntry (At (I))^. Ctx := I + 1;
  535. end;
  536.  
  537. { THelpFile = object (TBufStream) }
  538.  
  539. constructor THelpFile.Init(FileName: FNameStr; Mode, Size: Word);
  540. begin
  541.   inherited Init (FileName, Mode, Size);
  542.   if Mode = stCreate then
  543.     Write (FileStamp, SizeOf (FileStamp));
  544.  
  545.   IdxTbl. Init (MaxCollectionSize, 0);
  546.   IdxTbl. Duplicates := True;
  547. end;
  548.  
  549. destructor  THelpFile.Done;
  550. const NewPage: string [5] = '\page';
  551.       EndOfFile: Char = '}';
  552. var I: Integer;
  553. begin
  554.   IdxTbl. SetCtxs;
  555.  
  556.   System. Write ('                                                      '#13);
  557.   for I := 0 to IdxTbl.Count - 1 do begin
  558.     if I > 0 then
  559.       Write (NewPage [1], 5);
  560.     PIndexEntry (IdxTbl. At (I))^.Topic^.Write (
  561.       Self,
  562.       IdxTbl,
  563.       PIndexEntry (IdxTbl. At (I))^. Ctx,
  564.       PStr (PIndexEntry (IdxTbl. At (I))^. PS)^);
  565.  
  566.     System. Write (I, #13);
  567.   end;
  568.  
  569.   Write (EndOfFile, SizeOf (EndOfFile));
  570.  
  571.   IdxTbl. Done;
  572.   inherited Done;
  573. end;
  574.  
  575. end.
  576.